home *** CD-ROM | disk | FTP | other *** search
/ Australian Personal Computer 2002 November / CD 1 / APC0211D1.ISO / workshop / prog / files / ActivePerl-5.6.1.633-MSWin32.msi / _490b1bcc63e287f46a72ec2d199c0da6 < prev    next >
Encoding:
Text File  |  2002-05-30  |  6.2 KB  |  186 lines
  1.  
  2. sub mkTextConfig;
  3. sub textBs;
  4. sub textB1Move;
  5. sub textB1Press;
  6. sub textEnter;
  7.  
  8. sub mkCanvText {
  9.  
  10.     # Create a window containing a canvas displaying a text string and allowing the string to be edited and re-anchored.
  11.  
  12.     $mkCanvText->destroy if Exists($mkCanvText);
  13.     $mkCanvText = $top->Toplevel();
  14.     my $w = $mkCanvText;
  15.     dpos $w;
  16.     $w->title('Canvas Text Demonstration');
  17.     $w->iconname('Text');
  18.  
  19.     my $w_msg = $w->Label(-font => '-Adobe-Times-Medium-R-Normal--*-180-*-*-*-*-*-*', -wraplength => '5i',
  20.                -justify => 'left', -text => 'This window displays a string of text to demonstrate the text ' .
  21.                'facilities of canvas widgets.  You can point, click, and type.  You can also select and then ' .
  22.                'delete with Control-d.  You can copy the selection with Control-v.  You can click in the boxes ' .
  23.                'to adjust the position of the text relative to its positioning point or change its justification.');
  24.     my $c = $w->Canvas(-relief => 'flat', -bd => 0, -width => '500', -height => '400');
  25.     my $w_ok = $w->Button(-text => 'OK', -width => 8, -command => ['destroy', $w]);
  26.     $w_msg->pack(-side => 'top', -fill => 'both');
  27.     $c->pack(-side => 'top', -expand => 'yes', -fill => 'both');
  28.     $w_ok->pack(-side => 'bottom', -pady => '5', -anchor => 'center');
  29.  
  30.     $font = '-Adobe-helvetica-medium-r-normal--*-240-*-*-*-*-*-*';
  31.  
  32.     $c->create(qw(rectangle 245 195 255 205 -outline black -fill red));
  33.  
  34.     # First, create the text item and give it bindings so it can be edited.
  35.     
  36.     $c->addtag('text', 'withtag', $c->create('text', 250, 200, -text => 'This is just a string of text to demonstrate the ' .
  37.                          'text facilities of canvas widgets. You can point, click, and type.  You can ' .
  38.                          'also select and then delete with Control-d.', -width => 440, -anchor => 'n',
  39.                          -font => $font, -justify => 'left'));
  40.     $c->bind('text', '<1>' => sub {textB1Press(@_)});
  41.     $c->bind('text', '<B1-Motion>' => sub {textB1Move(@_)});
  42.     $c->bind('text', '<Shift-1>' => sub {
  43.     my($c) = @_;
  44.         my $e = $c->XEvent;
  45.     my($x, $y) = ($e->x, $e->y);
  46.     $c->select('adjust', 'current', "\@$x,$y");
  47.     });
  48.     $c->bind('text', '<Shift-B1-Motion>' => sub {textB1Move(@_)});
  49.     $c->bind('text', '<KeyPress>' => sub {
  50.     my($c) = @_;
  51.         my $e = $c->XEvent;
  52.     my $A = $e->A;
  53.     $c->insert('text', 'insert', "$A");
  54.     });
  55.     $c->bind('text', '<Shift-KeyPress>' => sub {
  56.     my($c) = @_;
  57.         my $e = $c->XEvent;
  58.     my $A = $e->A;
  59.     $c->insert('text', 'insert', "$A");
  60.     });
  61.     $c->bind('text', '<Return>' => sub {
  62.     my($c) = @_;
  63.         my $e = $c->XEvent;
  64.     $c->insert('text', 'insert', "\\n");
  65.     });
  66.     $c->bind('text', '<Control-h>' => sub {textBs(@_)});
  67.     $c->bind('text', '<Delete>' => sub {textBs(@_)});
  68.     $c->bind('text', '<Control-d>' => sub {
  69.     my($c, $e) = @_;
  70.         my $e = $c->XEvent;
  71.     $c->dchars('text', 'sel.first', 'sel.last');
  72.     });
  73.     $c->bind('text', '<Control-v>' => sub {
  74.     my($c, $e) = @_;
  75.         my $e = $c->XEvent;
  76.     $c->insert('text', 'insert', Tk::selection('get'));
  77.     });
  78.  
  79.     # Next, create some items that allow the text's anchor position to be edited.
  80.  
  81.     my($x, $y, $color) = (50, 50, 'LightSkyBlue1');
  82.     mkTextConfig $c, $x,    $y,    -anchor => 'se',      $color;
  83.     mkTextConfig $c, $x+30, $y,    -anchor => 's',       $color;
  84.     mkTextConfig $c, $x+60, $y,    -anchor => 'sw',      $color;
  85.     mkTextConfig $c, $x,    $y+30, -anchor => 'e',       $color;
  86.     mkTextConfig $c, $x+30, $y+30, -anchor => 'center',  $color;
  87.     mkTextConfig $c, $x+60, $y+30, -anchor => 'w',       $color;
  88.     mkTextConfig $c, $x,    $y+60, -anchor => 'ne',      $color;
  89.     mkTextConfig $c, $x+30, $y+60, -anchor => 'n',       $color;
  90.     mkTextConfig $c, $x+60, $y+60, -anchor => 'nw',      $color;
  91.     my $item = $c->create('rectangle', $x+40, $y+40, $x+50, $y+50, -outline => 'black', -fill => 'red');
  92.     $c->bind($item, '<1>' => sub {
  93.     my($c, $e) = @_;
  94.         my $e = $c->XEvent;
  95.     $c->itemconfigure('text', -anchor => 'center');
  96.     });
  97.     $c->create('text', $x+45, $y-5, -text => 'Text Position', -anchor => 's',
  98.            -font => '-Adobe-times-medium-r-normal--*-240-*-*-*-*-*-*', -fill => 'brown');
  99.  
  100.     # Lastly, create some items that allow the text's justification to be changed.
  101.     
  102.     $x = 350; $y = 50; $color = 'SeaGreen2';
  103.     mkTextConfig $c, $x,    $y,    -justify => 'left',   $color;
  104.     mkTextConfig $c, $x+30, $y,    -justify => 'center', $color;
  105.     mkTextConfig $c, $x+60, $y,    -justify => 'right',  $color;
  106.     $c->create('text', $x+45, $y-5, -text => 'Justification', -anchor => 's',
  107.            -font => '-Adobe-times-medium-r-normal--*-240-*-*-*-*-*-*', -fill => 'brown');
  108.  
  109.     $c->bind('config', '<Enter>' =>  sub {textEnter(@_)});
  110.     $c->bind('config', '<Leave>' => sub {
  111.     my($c, $e) = @_;
  112.         my $e = $c->XEvent;
  113.     $c->itemconfigure('current', -fill => $mkCanvText::textConfigFill);
  114.     });
  115.  
  116. } # end mkCanvText
  117.  
  118.  
  119. sub mkTextConfig {
  120.  
  121.     my($w, $x, $y, $option, $value, $color) = @_;
  122.  
  123.     my $item = $w->create('rectangle', $x, $y, $x+30, $y+30, -outline => 'black', -fill => $color, -width => 1);
  124.     $w->bind($item, '<1>', [sub {
  125.     my($w, $option, $value, $e) = @_;
  126.         my $e = $w->XEvent;
  127.  
  128.     $w->itemconfigure('text', $option => $value);
  129.     }, $option, $value]);
  130.     $w->addtag('config', 'withtag', $item);
  131.  
  132. } # end mkTextConfig
  133.  
  134. $mkCanvText::textConfigFill = 'purple';
  135.  
  136. sub textEnter {
  137.  
  138.     my($w) = @_;
  139.     my $e = $w->XEvent;
  140.  
  141.     $mkCanvText::textConfigFill =  ($w->itemconfigure('current', -fill))[4];
  142.     $w->itemconfigure('current', -fill => 'black');
  143.  
  144. } # end textEnter
  145.  
  146.  
  147. sub textB1Press {
  148.  
  149.     my($w) = @_;
  150.     my $e = $w->XEvent;
  151.  
  152.     my($x, $y) = ($e->x, $e->y);
  153.     $w->icursor('current', "\@$x,$y");
  154.     $w->focus('current');
  155.     $w->Tk::focus;
  156.     $w->select('from', 'current', "\@$x,$y");
  157.  
  158. } # end textB1Press
  159.  
  160.  
  161. sub textB1Move {
  162.  
  163.     my($w) = @_;
  164.     my $e = $w->XEvent;
  165.  
  166.     my($x, $y) = ($e->x, $e->y);
  167.     $w->select('to', 'current', "\@$x,$y");
  168.  
  169. } # end textB1Move
  170.  
  171.  
  172. sub textBs {
  173.  
  174.     my($w) = @_;
  175.     my $w = $c->XEvent;
  176.  
  177.     my $char = $w->index('text', 'insert') - 1;
  178.     $w->dchar('text', $char) if $char >= 0;
  179.  
  180. } # end textBs
  181.  
  182.  
  183. 1;
  184.  
  185.  
  186.